home *** CD-ROM | disk | FTP | other *** search
/ Graphics Plus / Graphics Plus.iso / msdos / viewers / gif_pas / relace.pas < prev   
Pascal/Delphi Source File  |  1988-04-13  |  6KB  |  180 lines
  1. program RELACE;
  2. uses CRT,DEGIF,ENGIF;
  3.  
  4. const YInc:array [1..5] of integer=(8,8,4,2,1);
  5.       YLin:array [1..5] of integer=(0,4,2,1,0);
  6.  
  7. type Line=array [0..1023] of byte;
  8.  
  9. var  Lines:array [0..479] of ^Line;
  10.      InFileName,OutFileName:string;
  11.      YN,BlockType:char;
  12.      Pass:byte;
  13.      Bottom,Left,Right,Top,XCord,YCord:integer;
  14.      InFile,OutFile:file of byte;
  15.      LaceIt:boolean;
  16.      PixCount:longint;
  17.  
  18. procedure Abort;
  19.  begin
  20.   close(OutFile); close(InFile); halt
  21.  end;
  22.  
  23. {$F+}
  24. function GetByte: byte;
  25.  var B:byte;
  26.  begin
  27.   read(InFile,B);
  28.   GetByte:=B
  29. end;
  30. {$F-}
  31.  
  32. {$F+}
  33. procedure PutByte(Pix: integer);
  34. var P:byte;
  35. begin
  36.  P:=lo(Pix);
  37.  Lines[YCord]^[XCord]:=P;
  38.  inc(PixCount);  inc(XCord);
  39.  if XCord > Right
  40.   then begin Write(YCord:5);  XCord:=Left;  inc(YCord,YInc[Pass]);
  41.              if YCord > Bottom
  42.               then begin inc(Pass); YCord:=YLin[Pass]+Top end
  43.        end
  44. end;
  45. {$F-}
  46.  
  47. {$F+}
  48. procedure WrtByte(I: integer);
  49.  var B:byte;
  50.  begin
  51.   B:=lo(I);
  52.   write(OutFile,B)
  53.  end;
  54. {$F-}
  55.  
  56. procedure AdjustImage;
  57.  begin
  58.   Left  := ImageLeft;
  59.   Top   := ImageTop;
  60.   Right := ImageWidth + Left -1;
  61.   Bottom:= ImageHeight + Top -1;
  62.   XCord:=Left;   YCord:=Top;
  63.   if Interlaced then Pass:=1 else Pass:=5;
  64.   Writeln;
  65.   Writeln('Left  =',Left:6, '  Top=   ',Top:6);
  66.   Writeln('Right =',Right:6  ,'  Bottom=',Bottom:6);
  67.   if Interlaced
  68.    then
  69.     begin
  70.      Write('Image is interlaced.  Do you want to un-lace it? [Y/n]');
  71.      YN:=ReadKey;  writeln; LaceIt:=not(YN in ['y','Y',#13])
  72.     end
  73.    else
  74.     begin
  75.      Write('Image is not interlaced.  Do you want to lace it? [Y/n]');
  76.      YN:=ReadKey;  writeln; LaceIt:=YN in ['y','Y',#13]
  77.     end
  78.  end;
  79.  
  80. procedure DisplayScrDes;
  81. var AnsCh:char;
  82. begin
  83.  Writeln('Screen width =',ScreenWidth:5, '  Screen height   =',ScreenHeight:5);
  84.  Writeln('Bits of color=',BitsOfColorPerPrimary:5,
  85.          '  Number of colors=',NumberOfColors[Global]:5)
  86. end;
  87.  
  88. begin
  89.  AddrWrtByte:=@WrtByte;
  90.  AddrGetByte:=@GetByte;
  91.  AddrPutByte:=@PutByte;
  92.  AssignCrt(output);Rewrite(OUTPUT);
  93.  writeln('ReLace version 0.1 demo for DEGIF & ENGIF Turbo Pascal Unit');
  94.  writeln('   Interlaces or De-interlaces and re-encodes GIF images');
  95.  writeln('     Copyright (c) 1988 Cyborg Software Systems, Inc.');writeln;
  96.  writeln('        GIF and "Graphics Interchange Format" are');
  97.  writeln('       trademarks (tm) of CompuServe Incorporated');
  98.  writeln('                  an H&R Block Company.');writeln;writeln;
  99.  if paramcount<1
  100.   then begin
  101.         write('Enter GIF input file name:  '); readln(infilename);
  102.        end
  103.   else InFileName:=paramstr(1);
  104.  if paramcount<2
  105.   then begin
  106.         write('Enter GIF output input file name:  '); readln(outfilename);
  107.        end
  108.   else OutFileName:=paramstr(2);
  109.  if (length(InFileName)>0) and (length(OutFileName)>0) then
  110.   begin
  111.    assign(InFile,InFileName);
  112.    {$I-}
  113.    reset(InFile);
  114.    if ioresult<>0
  115.     then begin writeln('GIF datafile could not be found.'); halt end;
  116.    assign(OutFile,OutFileName);
  117.    rewrite(OutFile);
  118.    if ioresult<>0
  119.     then begin writeln('GIF output file could not be opened.'); halt end;
  120.    CurMap:=Global;
  121.    GetGIFSig;
  122.    if GIFSig<>'GIF87a' then begin writeln('Invalid GIF ID'); Abort end;
  123.    PutGIFSig;
  124.    GetScrDes;
  125.    if ScreenWidth>1024 then begin writeln('Screen too big'); Abort end;
  126.    for YCord:=0 to ScreenHeight-1 do 
  127.     begin 
  128.      getmem(Lines[YCord],ScreenWidth);
  129.      for XCord:=0 to ScreenWidth-1 do Lines[YCord]^[XCord]:=BackgrColorIndex
  130.     end;
  131.    DisplayScrDes;
  132.    PutScrDes(ScreenWidth,ScreenHeight,BackgrColorIndex,
  133.              BitsOfColorPerPrimary,BitsPerPixel[Global],
  134.              MapExists[Global]);
  135.    if MapExists[Global] then begin GetColorMap; PutColorMap end;
  136.    while not EOF(InFile) Do
  137.     begin
  138.      BlockType:=chr(GetByte);
  139.      case BlockType of
  140.       ',':begin
  141.            Writeln('Image separator "," found.');
  142.            WrtByte(ord(','));
  143.            GetImageDescription;
  144.            AdjustImage;
  145.            PutImageDescription(ImageLeft,ImageTop,ImageWidth,
  146.                                ImageHeight,BitsPerPixel[Local],
  147.                                MapExists[Local],LaceIt);
  148.            if MapExists[Local]
  149.             then begin CurMap:=Local; GetColorMap; PutColorMap end
  150.             else CurMap:=Global;
  151.            Writeln('Decoding...');PixCount:=0;
  152.            if ExpandGIF <>0 then Halt;
  153.            writeln; writeln(PixCount:10,' Pixels read.');
  154.            writeln('Encoding...');
  155.            if LaceIt then Pass:=1 else Pass:=5;
  156.            YCord:=Top; PixCount:=0;
  157.            repeat
  158.             for XCord:=Left to Right
  159.              do begin inc(PixCount); CompressGIF(Lines[YCord]^[XCord]) end;
  160.             write(YCord:5);  inc(YCord,YInc[Pass]);
  161.             if YCord > Bottom
  162.              then begin inc(Pass); YCord:=YLin[Pass]+Top end
  163.            until (LaceIt and (Pass>4)) or (Pass>5);
  164.            EndCompress; writeln;
  165.            writeln(PixCount:10,' Pixels written.');
  166.           end;
  167.       '!':begin
  168.            WrtByte(ord(BlockType));
  169.            SkipExtendBlock; Writeln('Expansion block "!" found.')
  170.           end;
  171.       ';':begin
  172.            Writeln('GIF Terminator ";" found.');
  173.            WrtByte(ord(';'));
  174.            Sound(440);Delay(100);NoSound;Abort
  175.           end;
  176.      end;
  177.     end;
  178.   end;
  179. end.
  180.